home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue32 / globe / GLOBE.ZIP / uDemo.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1998-02-18  |  13.7 KB  |  505 lines
  1. {-------------------------------------------------------------------------
  2.     Module:        TGlobe Demo program
  3.  
  4.     Comment:    Simple demo program for TGlobe.
  5.  
  6.     Author:        Graham Knight
  7.     Email:        gknight@helmstone.co.uk
  8.     Version:    2.2
  9.     Date:            January 1998
  10.  
  11.     2.1a:     Fix to object selection in lbxLocationsclick()
  12. -------------------------------------------------------------------------}
  13. unit uDemo;
  14.  
  15. interface
  16.  
  17. uses
  18.     WinProcs, WinTypes, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  19.     Dialogs, StdCtrls, Buttons, ExtCtrls, Menus, Tabs, inifiles, Spin;
  20.  
  21. type
  22.     TfrmMain = class(TForm)
  23.         MainMenu1: TMainMenu;
  24.         File1: TMenuItem;
  25.         Open1: TMenuItem;
  26.         N1: TMenuItem;
  27.         Exit1: TMenuItem;
  28.         Panel3: TPanel;
  29.         Globe: TGlobe;
  30.         OpenDialog1: TOpenDialog;
  31.         pnlHint: TPanel;
  32.         View1: TMenuItem;
  33.         Spherical1: TMenuItem;
  34.         Mercator1: TMenuItem;
  35.         Cartesian1: TMenuItem;
  36.         Panel1: TPanel;
  37.     Notebook1: TNotebook;
  38.     lbxLocations: TListBox;
  39.     Panel4: TPanel;
  40.     btnType: TButton;
  41.     btnTitle: TButton;
  42.     pnlZoom: TPanel;
  43.     btnZoomIn: TBitBtn;
  44.     btnZoomOut: TBitBtn;
  45.     btnZoomExtents: TBitBtn;
  46.     SpinButton1: TSpinButton;
  47.     tabLayers: TTabSet;
  48.     OpenProfile1: TMenuItem;
  49.         OpenDialog3: TOpenDialog;
  50.     NewGlobe: TMenuItem;
  51.     N2: TMenuItem;
  52.     ThematicMapping1: TMenuItem;
  53.     Timer1: TTimer;
  54.     N3: TMenuItem;
  55.     Print1: TMenuItem;
  56.         procedure btnZoomInClick(Sender: TObject);
  57.         procedure btnZoomOutClick(Sender: TObject);
  58.         procedure btnZoomExtentsClick(Sender: TObject);
  59.         procedure lbxLocationsClick(Sender: TObject);
  60.         procedure FormCreate(Sender: TObject);
  61.         procedure Open1Click(Sender: TObject);
  62.         procedure Exit1Click(Sender: TObject);
  63.         procedure lbxLocationsDrawItem(Control: TWinControl; Index: Integer;
  64.             Rect: TRect; State: TOwnerDrawState);
  65.         procedure GlobeRender(Sender: TObject);
  66.         procedure ProjectionClick(Sender: TObject);
  67.         procedure btnHeaderClick(Sender: TObject);
  68.         procedure SpinButton1DownClick(Sender: TObject);
  69.         procedure SpinButton1UpClick(Sender: TObject);
  70.         procedure tabLayersClick(Sender: TObject);
  71.         procedure OpenProfile1Click(Sender: TObject);
  72.         procedure NewGlobeClick(Sender: TObject);
  73.         procedure GlobeSelected(Sender: TObject);
  74.         procedure GlobeMouseMove(Sender: TObject; Shift: TShiftState; X,
  75.             Y: Integer);
  76.     procedure GlobeRenderAttributes(Sender: TObject;
  77.       GlobeObject: TGlobeObject; var Done: Boolean);
  78.     procedure ThematicMapping1Click(Sender: TObject);
  79.     procedure Timer1Timer(Sender: TObject);
  80.     procedure Print1Click(Sender: TObject);
  81.     private
  82.         { Private declarations }
  83.     public
  84.         { Public declarations }
  85.         procedure RebuildTabs;
  86.         procedure LoadFile( const sFname : string );
  87.         procedure LoadProfile( const sPname : string );
  88.     end;
  89.  
  90. {-------------------------------------------------------------------------}
  91. var
  92.     frmMain: TfrmMain;
  93.     gCurrentLayer : TGlobeLayer;
  94.     MyObject : TGlobeSymbol;
  95.  
  96. {-------------------------------------------------------------------------}
  97. implementation
  98.  
  99. {$R *.DFM}
  100.  
  101. {-------------------------------------------------------------------------}
  102. procedure TfrmMain.RebuildTabs;
  103. var
  104.     idx : integer;
  105. begin
  106.     with tabLayers do
  107.     begin
  108.         Tabs.Clear;
  109.         for idx := 0 to Globe.LayerCount - 1 do
  110.             Tabs.AddObject( Globe[idx].Name, Globe[idx] );
  111.         if Tabs.Count > 0 then
  112.             TabIndex := 0;
  113.     end;
  114. end;
  115.  
  116. {-------------------------------------------------------------------------}
  117. procedure TfrmMain.LoadFile( const sFname : string );
  118. var
  119.     ALayer : TGlobeLayer;
  120. begin
  121.     with tablayers do
  122.     begin
  123.         ALayer := Globe.LayerNew( '' );
  124.         ALayer.MaxFontHeight := 10;        { default font height }
  125.         ALayer.LoadFromFile( sFname );
  126.  
  127.         Tabs.AddObject( ALayer.Name, ALayer );
  128.         TabIndex := Tabs.Count - 1;
  129.     end;
  130. end;
  131.  
  132. {-------------------------------------------------------------------------}
  133. procedure TfrmMain.NewGlobeClick(Sender: TObject);
  134. begin
  135.     lbxLocations.Clear;
  136.     tabLayers.Tabs.Clear;
  137.     Globe.Clear;
  138.     MyObject := nil;
  139. end;
  140.  
  141. {-------------------------------------------------------------------------}
  142. procedure TfrmMain.LoadProfile( const sPname : string );
  143. begin
  144.     NewGlobeClick( nil );
  145.     Globe.ProfileName := sPname;
  146.     RebuildTabs;
  147. end;
  148.  
  149. {-------------------------------------------------------------------------}
  150. procedure TfrmMain.SpinButton1DownClick(Sender: TObject);
  151. begin
  152.     with Globe do
  153.         ScaleFactor := ScaleFactor / 1.1;
  154. end;
  155.  
  156. {-------------------------------------------------------------------------}
  157. procedure TfrmMain.SpinButton1UpClick(Sender: TObject);
  158. begin
  159.     with Globe do
  160.         ScaleFactor := ScaleFactor * 1.1;
  161. end;
  162.  
  163. {-------------------------------------------------------------------------}
  164. procedure TfrmMain.btnZoomInClick(Sender: TObject);
  165. begin
  166.     with Globe do
  167.         ScaleFactor := ScaleFactor * 2;
  168. end;
  169.  
  170. {-------------------------------------------------------------------------}
  171. procedure TfrmMain.btnZoomOutClick(Sender: TObject);
  172. begin
  173.     with Globe do
  174.         ScaleFactor := ScaleFactor / 2;
  175. end;
  176.  
  177. {-------------------------------------------------------------------------}
  178. procedure TfrmMain.btnZoomExtentsClick(Sender: TObject);
  179. begin
  180.     with Globe do
  181.         if SelectedObject <> nil then
  182.         begin
  183.             ViewRect := SelectedObject.BoundsRectLL;
  184.             ObjectLocate( SelectedObject );
  185.         end
  186.         else
  187.             ViewRect := Rect( 0, 0, 0, 0 );
  188. end;
  189.  
  190. {-------------------------------------------------------------------------}
  191. procedure TfrmMain.lbxLocationsClick(Sender: TObject);
  192. begin
  193.     with lbxLocations do
  194.         if ItemIndex <> -1 then
  195.         begin
  196.             Globe.SelectedObject := TGlobeObject( Items.Objects[ItemIndex] );
  197.             Globe.ObjectLocate( TGlobeObject( Items.Objects[ItemIndex] ));
  198.         end;
  199. end;
  200.  
  201. {-------------------------------------------------------------------------}
  202. procedure TfrmMain.FormCreate(Sender: TObject);
  203. var
  204.     ALayer : TGlobeLayer;
  205. begin
  206.     LoadProfile( 'tglobe.prf' );    { load the default profile }
  207.  
  208.     ALayer := Globe.LayerNew( 'Animated' );
  209.     ALayer.Animated := True;
  210.     ALayer.ScaleFont := False;
  211.     MyObject := TGlobeSymbol.Create( ALayer, 'AirCraft', 0, 0, 81 );
  212.     MyObject.ObjectFont := TGlobeFont.Define( ALayer, 'WingDings', clRed, NauticalMile, 20, 0, [] );
  213.  
  214.     Globe.ViewRect := Rect( 0, 0, 0, 0 );
  215. end;
  216.  
  217. {-------------------------------------------------------------------------}
  218. procedure TfrmMain.Exit1Click(Sender: TObject);
  219. begin
  220.     Close;
  221. end;
  222.  
  223. {-------------------------------------------------------------------------}
  224. procedure TfrmMain.Open1Click(Sender: TObject);
  225. begin
  226.     with OpenDialog1 do
  227.     begin
  228.         InitialDir := ExtractFilePath(Application.ExeName);
  229.         FileName := '';
  230.  
  231.         if Execute then
  232.             LoadFile( FileName );
  233.     end;
  234. end;
  235.  
  236. {-------------------------------------------------------------------------}
  237. procedure TfrmMain.OpenProfile1Click(Sender: TObject);
  238. begin
  239.     with OpenDialog3 do
  240.     begin
  241.         InitialDir := ExtractFilePath(Application.ExeName);
  242.         FileName := Globe.ProfileName;
  243.         if Execute then
  244.             LoadProfile( FileName );
  245.     end;
  246. end;
  247.  
  248. {-------------------------------------------------------------------------}
  249. procedure TfrmMain.lbxLocationsDrawItem(Control: TWinControl;
  250.     Index: Integer; Rect: TRect; State: TOwnerDrawState);
  251. var
  252.     oObj : TGlobeObject;
  253. begin
  254.     with lbxLocations do
  255.     begin
  256.         oObj := TGlobeObject( Items.Objects[Index] );
  257.         Canvas.TextRect( Rect, Rect.Left, Rect.Top, Copy( oObj.ClassName, 7, 255 ));
  258.  
  259.         Rect.Left := btnType.Width;
  260.         Canvas.TextRect( Rect, Rect.Left, Rect.Top, oObj.Title);
  261.     end;
  262. end;
  263.  
  264. {-------------------------------------------------------------------------}
  265. procedure TfrmMain.btnHeaderClick(Sender: TObject);
  266. var
  267.     idx, jdx : integer;
  268.     iGap : integer;
  269.     lExchanges : Longint;
  270.     bSwap : Boolean;
  271. begin
  272.     Screen.Cursor := crHourGlass;
  273.     with lbxLocations do
  274.     begin
  275.         Items.BeginUpdate;
  276.  
  277.         bSwap := False;
  278.  
  279.         iGap := Items.Count - 1;
  280.         repeat
  281.             iGap := Trunc( iGap / 1.3 );
  282.             Case iGap of
  283.             0 :            iGap := 1;
  284.             9,10 :    iGap := 11;
  285.             end;
  286.  
  287.             lExchanges := 0;
  288.             for idx := 0 to Items.Count - 1 - iGap do
  289.             begin
  290.                 jdx := idx + iGap;
  291.  
  292.                 case TBitBtn( Sender ).Tag of
  293.                 0 :    { By Type }
  294.                     bSwap := TGlobeObject( Items.objects[idx]).ClassName > TGlobeObject( Items.objects[jdx]).ClassName;
  295.                 1 :    { By Title }
  296.                     bSwap := TGlobeObject( Items.objects[idx]).Title > TGlobeObject( Items.objects[jdx]).Title;
  297.                 end;
  298.  
  299.                 if bSwap then
  300.                 begin
  301.                     Items.Exchange( idx, jdx );
  302.                     Inc( lExchanges );
  303.                 end;
  304.             end;
  305.         until ( lExchanges = 0 ) and ( iGap = 1 );
  306.  
  307.         Items.EndUpdate;
  308.     end;
  309.     Screen.Cursor := crDefault;
  310. end;
  311.  
  312. {-------------------------------------------------------------------------}
  313. procedure TfrmMain.GlobeRender(Sender: TObject);
  314. var
  315.     iLeft, iTop, iBkMode, iTA : integer;
  316.     Units : TGlobeUnits;
  317. begin
  318.     iLeft := Globe.Width - ( 50 + Screen.PixelsPerInch );
  319.     iTop := Globe.Height - 50;
  320.     with Globe.GlobeCanvas do
  321.     begin
  322.         Font.Assign( Self.Font );
  323.  
  324.         iBkMode := SetBkMode( Handle, TRANSPARENT );
  325.         iTA := SetTextAlign( Handle, TA_CENTER );
  326.  
  327.         Font.Color := clRed;
  328.         TextOut( iLeft, iTop, '0' );
  329.         Units := KiloMeter;
  330.         if GlobeUnitsTo( Globe.GlobeUnitsPerInch, KiloMeter ) < 10 then
  331.             if GlobeUnitsTo( Globe.GlobeUnitsPerInch, Meter ) < 10 then
  332.                 Units := Centimeter
  333.             else
  334.                 Units := Meter;
  335.  
  336.         Font.Color := clRed;
  337.         TextOut( iLeft + Screen.PixelsPerInch, iTop,
  338.             Format( '%d %s',[GlobeUnitsTo( Globe.GlobeUnitsPerInch, Units ), UnitsToStr( Units )] ));
  339.  
  340.         SetBkMode( Handle, iBkMode );
  341.         SetTextAlign( Handle, iTA );
  342.  
  343.         Pen.color := clRed;
  344.         MoveTo( iLeft, iTop + 16 );
  345.         LineTo( iLeft, iTop + 20 );
  346.         LineTo( iLeft + Screen.PixelsPerInch, iTop + 20 );
  347.         LineTo( iLeft + Screen.PixelsPerInch, iTop + 15 );
  348.     end;
  349. end;
  350.  
  351. {-------------------------------------------------------------------------}
  352. procedure TfrmMain.ProjectionClick(Sender: TObject);
  353. begin
  354.     Spherical1.Checked := False;
  355.     Mercator1.Checked := False;
  356.     Cartesian1.Checked := False;
  357.  
  358.     with Sender as TmenuItem do
  359.         Checked := True;
  360.  
  361.     if Spherical1.Checked then
  362.         Globe.Projection := gpSpherical;
  363.     if Mercator1.Checked then
  364.         Globe.Projection := gpMercator;
  365.     if Cartesian1.Checked then
  366.         Globe.Projection := gpCartesian;
  367. end;
  368.  
  369. {-------------------------------------------------------------------------}
  370. procedure TfrmMain.tabLayersClick(Sender: TObject);
  371. var
  372.     iPoints, idx : integer;
  373. begin
  374.     Screen.Cursor := crHourGlass;
  375.  
  376.     with lbxLocations do
  377.     try
  378.         Items.BeginUpdate;
  379.         Clear;
  380.  
  381.         iPoints := 0;
  382.         with tabLayers do
  383.             if TabIndex <> -1 then
  384.             begin
  385.                 gCurrentLayer := TGlobeLayer( Tabs.Objects[TabIndex] );
  386.                 with gCurrentLayer do
  387.                 begin
  388.                     for idx := 0 to ObjectCount - 1 do
  389.                         if idx < 32700 then
  390.                             if ( Objects[idx] is TGlobePolyline )    then
  391.                             begin
  392.                                 Items.AddObject( '', Objects[idx] );
  393.                                 Inc( iPoints, TGLobePolyLine( Objects[idx] ).LLPointList.Count )
  394.                             end
  395.                             else
  396.                             if ( Objects[idx] is TGlobeText ) then
  397.                             begin
  398.                                 Items.AddObject( '', Objects[idx] );
  399.                                 Inc( iPoints );
  400.                             end;
  401.                     pnlHint.Caption := Format( 'Objects %d'#10'Points %d', [ObjectCount, iPoints] );
  402.                 end;
  403.             end;
  404.     finally
  405.         Items.EndUpdate;
  406.         Screen.Cursor := crDefault;
  407.     end;
  408. end;
  409.  
  410.  
  411. {-------------------------------------------------------------------------}
  412. procedure TfrmMain.GlobeSelected(Sender: TObject);
  413. var
  414.     idx : integer;
  415. begin
  416.     if Globe.SelectedObject <> nil then
  417.     begin
  418.         btnZoomExtents.Caption := 'Object Extents';
  419.         if gCurrentLayer <> Globe.SelectedObject.Layer then
  420.             with TabLayers do
  421.                 for idx := 0 to Tabs.Count - 1 do
  422.                     if TGlobeLayer( Tabs.objects[idx] ) = Globe.SelectedObject.Layer then
  423.                     begin
  424.                         tabIndex := idx;
  425.                         Break;
  426.                     end;
  427.  
  428.         with lbxLocations do
  429.             ItemIndex := Items.IndexOfObject( Globe.SelectedObject );
  430.     end
  431.     else
  432.         btnZoomExtents.Caption := 'World Extents';
  433. end;
  434.  
  435. {-------------------------------------------------------------------------}
  436. procedure TfrmMain.GlobeMouseMove(Sender: TObject; Shift: TShiftState; X,
  437.     Y: Integer);
  438. var
  439.     sTmp : string;
  440.     pt : TPointLL;
  441.     MouseObj : TGlobeObject;
  442. begin
  443.     with Globe do
  444.     begin
  445.         DeviceXYToLL( X, Y, pt );
  446.  
  447.         with pt do
  448.             sTmp := LLToStr( X, '%d.%m.%s.%t%E ' ) + LLToStr( Y, '%d.%m.%s.%t%N' );
  449.  
  450.         MouseObj := ObjectAtXY( X, Y );
  451.         if MouseObj <> nil then
  452.             sTmp := sTmp + ' ' + MouseObj.Title;
  453.  
  454.         pnlHint.Caption := Format( ' Mouse Position: %s', [sTmp] );
  455.     end;
  456. end;
  457.  
  458. {-------------------------------------------------------------------------}
  459. procedure TfrmMain.ThematicMapping1Click(Sender: TObject);
  460. begin
  461.     ThematicMapping1.Checked := not ThematicMapping1.Checked;
  462.     Globe.Redraw;
  463. end;
  464.  
  465. {-------------------------------------------------------------------------}
  466. procedure TfrmMain.GlobeRenderAttributes(Sender: TObject;
  467.     GlobeObject: TGlobeObject; var Done: Boolean);
  468. const
  469.     aColors: array[0..13] of TColor = (clBlack,clMaroon,clGreen,clOlive,clPurple,
  470.     clTeal,clGray,clSilver,clRed,clLime,clYellow,clBlue,clFuchsia,clWhite);
  471. begin
  472.     if ThematicMapping1.Checked then
  473.         if GlobeObject is TGlobePolygon then
  474.             if GlobeObject.Layer.Name = 'Countries' then
  475.             begin
  476.                 Globe.GlobeCanvas.Brush.Color := aColors[( GlobeObject.Index mod 14)];
  477.                 Globe.GlobeCanvas.Pen.Color := aColors[( GlobeObject.Index mod 14)];
  478.                 Done := True;
  479.             end;
  480. end;
  481.  
  482. {-------------------------------------------------------------------------}
  483. procedure TfrmMain.Timer1Timer(Sender: TObject);
  484. var
  485.     ix, iY : integer;
  486. begin
  487.     if MyObject <> nil then
  488.         with MyObject.Origin do
  489.         begin
  490.             iX := ( X + GU_DEGREE ) mod GU_360_DEGREE;
  491.             iY := Round( 45 * GU_DEGREE * Sin( AngleToRadians( X )));
  492.             MyObject.Origin := PointLL( ix, iY );
  493.             MyObject.RedrawObject;
  494.         end;
  495. end;
  496.  
  497.  
  498. {-------------------------------------------------------------------------}
  499. procedure TfrmMain.Print1Click(Sender: TObject);
  500. begin
  501.     Globe.Print;
  502. end;
  503.  
  504. end.
  505.